home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
001
/
wwiv.arc
/
DLOADS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1986-04-06
|
26KB
|
983 lines
Program dloads;
{*****************************}
{Copyright (c) 1986 Wayne Bell}
{*****************************}
{$V-} {$C-}
{$I COMMON.PAS}
var ulf:file of ulrec;
uboards:array[0..19] of ulrec;
ulff:file of ulfrec;
crc,culb,maxulb:integer;
sortbd,doneft:boolean;
ldat:str;
ymodem,ucrc,bnp:boolean;
chksum:byte;
lrn:integer;
lfn:str;
ft:byte;
procedure printfile(fn:str);
var fil:text;
i:str;
abort,next:boolean;
begin
if not hangup then begin
assign(fil,fn);
{$I-} reset(fil); {$I+}
if ioresult<>0 then print('File not found.') else begin
abort:=false;
while not eof(fil) and (not abort) and (not hangup) do begin
readln(fil,i);
if i[length(i)]<>#1 then i:=i+#1;
printa(i,abort,next);
end;
close(fil);
end;
nl;nl;
end;
end;
function tcheck(s:real; i:integer):boolean;
var r:real;
begin
r:=timer;
if r<s then r:=r+86400.0;
if trunc(r-s)>i then tcheck:=false else tcheck:=true;
end;
function tchk(s:real; i:real):boolean;
var r:real;
begin
r:=timer;
if r<s then r:=r+86400.0;
if (r-s)>i then tchk:=false else tchk:=true;
end;
{$I DLP1.PAS}
procedure i1;
begin
assign(ulf,'gfiles\uploads.dat');
reset(ulf); maxulb:=-1;
while not eof(ulf) do begin maxulb:=maxulb+1; read(ulf,uboards[maxulb]); end;
close(ulf);
culb:=1;
ldat:=thisuser.laston;
end;
function exist(fn:str):boolean;
var f:file;
begin
assign(f,fn);
{$I-} reset(f); {$I+}
if ioresult=0 then begin close(f); exist:=true end else exist:=false;
end;
function align(fn:str):str;
var f,e,t:str; c,c1:integer;
begin
c:=pos('.',fn);
if c=0 then begin
f:=fn; e:=' ';
end else begin
f:=copy(fn,1,c-1); e:=copy(fn,c+1,3);
end;
while length(f)<8 do f:=f+' ';
while length(e)<3 do e:=e+' ';
if length(f)>8 then f:=copy(f,1,8);
if length(e)>3 then e:=copy(e,1,3);
c:=pos('*',f); if c<>0 then for c1:=c to 8 do f[c1]:='?';
c:=pos('*',e); if c<>0 then for c1:=c to 3 do e[c1]:='?';
c:=pos(' ',f); if c<>0 then for c1:=c to 8 do f[c1]:=' ';
c:=pos(' ',e); if c<>0 then for c1:=c to 3 do e[c1]:=' ';
align:=f+'.'+e;
end;
function fit(f1,f2:str):boolean;
var tf:boolean; c:integer;
begin
tf:=true;
for c:=1 to 12 do
if (f1[c]<>f2[c]) and (f1[c]<>'?') then tf:=false;
fit:=tf;
end;
procedure iscan(var pl:integer);
var f:ulfrec;
begin
assign(ulff,'gfiles\'+uboards[culb].filename);
{$I-} reset(ulff); {$I+}
if ioresult<>0 then begin
rewrite(ulff);
f.blocks:=0;
write(ulff,f);
end;
seek(ulff,0);
read(ulff,f);
pl:=f.blocks;
bnp:=false;
end;
procedure recno(fn:str; var pl,rn:integer);
var c:integer;
f:ulfrec;
begin
fn:=align(fn);
iscan(pl); rn:=0; c:=1;
while (c<=pl) and (rn=0) do begin
seek(ulff,c); read(ulff,f);
if fit(fn,align(f.filename)) then rn:=c;
c:=c+1;
end;
lrn:=rn;
lfn:=fn;
end;
procedure nrecno(fn:str; var pl,rn:integer);
var c:integer;
f:ulfrec;
begin
fn:=align(fn);
if fn=lfn then begin
if (lrn<pl) and (lrn>0) then begin
c:=lrn+1; rn:=0;
while (c<=pl) and (rn=0) do begin
seek(ulff,c); read(ulff,f);
if fit(fn,align(f.filename)) then rn:=c;
c:=c+1;
end;
lrn:=rn;
end else rn:=0;
end else rn:=0;
end;
procedure arcl(fn:str; var abort:boolean);
type ei=record l,h:integer; end;
archead=record
name:array[1..13] of char;
size:ei;
date,time,crc:integer;
len:ei;
end;
var f:file; b:byte;
head:archead;
done,next:boolean;
function valueei(x:ei):real;
var r:real; tf:boolean;
begin
if x.h>=0 then begin r:=int(x.h)*65536.0; tf:=true; end else
begin tf:=false; if x.h=$8000 then r:=65536.0*65536.0 else
r:=int(-x.h)*65536.0; end;
if x.l>=0 then r:=r+int(x.l)
else if x.l=$8000 then r:=r+32760.0
else r:=r+65536.0+x.l;
if tf then valueei:=r else valueei:=-r;
end;
procedure pfn;
var i,i1:str; try:byte;
begin
b:=0; try:=0;
while not eof(f) and (b<>26) and (try<5) do begin
blockread(f,b,1);
try:=try+1;
end;
if try>=5 then longseek(f,filesize(f)-2.0);
if longfilepos(f)+27<longfilesize(f) then begin
blockread(f,b,1);
if b<>0 then begin
if b=1 then begin
blockread(f,head,sizeof(head)-sizeof(ei));
head.len:=head.size;
end else blockread(f,head,sizeof(head));
i:=''; b:=1;
while (head.name[b]<>#0) and (b<=13) do begin
i:=i+head.name[b];
b:=b+1;
end;
i:=align(i)+' ';
i1:=cstrr(valueei(head.len));
while length(i1)<7 do i1:=' '+i1;
i:=i+i1;
printacr(i,abort,next);
end else done:=true;
longseek(f,longfilepos(f)+valueei(head.size));
end;
end;
begin
assign(f,fn);
reset(f,1); done:=false;
while (longfilepos(f)+27.0<longfilesize(f)) and not (abort or done) do
pfn;
close(f);
end;
procedure lbrl(fn:str; var abort:boolean);
var f:file;
c,n,n1:integer;
x:record
st:byte;
name:array[1..8] of char;
ext:array[1..3] of char;
index,len:integer;
fil:array[1..16] of byte;
end;
next:boolean;
i,i1:str;
begin
assign(f,fn);
reset(f,32);
blockread(f,x,1);
c:=x.len*4-1;
for n:=1 to c do begin
blockread(f,x,1); i:='';
if (x.st=0) and not abort then begin
for n1:=1 to 8 do i:=i+x.name[n1];
i:=i+'.';
for n1:=1 to 3 do i:=i+x.ext[n1];
i:=align(i)+' ';
i1:=cstrr(x.len*128.0);
while length(i1)<7 do i1:=' '+i1;
i:=i+i1;
printacr(i,abort,next);
end;
end;
close(f);
end;
procedure lfi(fn:str; var abort:boolean);
var next:boolean; i1,i2:str;
begin
if exist('dloads\'+fn) and (not abort) then
if (pos('.ARC',fn)<>0) or (pos('.LBR',fn)<>0) then begin
nl;
i1:=align(fn); i2:=''; while length(i1)>length(i2) do i2:=i2+'-';
printacr(i1,abort,next);
printacr(i2,abort,next);
nl;
if not abort then begin
if pos('.ARC',fn)<>0 then arcl('dloads\'+fn,abort);
if pos('.LBR',fn)<>0 then lbrl('dloads\'+fn,abort);
end;
nl;
end;
end;
procedure lfin(rn:integer; var abort:boolean);
var f:ulfrec;
begin
seek(ulff,rn); read(ulff,f); lfi(f.filename,abort);
end;
procedure lfii;
var fn:str; pl,rn:integer; abort:boolean;
begin
helpl:='[';
nl; print('Enter file to list interior files of');
prompt(': '); input(fn,12);
recno(fn,pl,rn);
abort:=false;
if rn=0 then print('File not found.') else begin
while (rn<>0) and (not abort) do begin
lfin(rn,abort);
nrecno(fn,pl,rn);
end;
end;
close(ulff);
end;
procedure return;
var f:file;
begin
assign(f,'bbs.com');
print('Returning to BBS...');
remove_port;
if hangup then term_ready(false);
execute(f);
end;
procedure pbn(var abort:boolean);
var i,i1:str; next:boolean;
begin
if not bnp then begin
nl;
i:=uboards[culb].name+' #'+cstr(culb);
i1:='---'; while length(i1)<length(i) do i1:=i1+'-';
nl; nl;
printacr(i,abort,next);
printacr(i1,abort,next);
nl;
end;
bnp:=true;
end;
function uc(s:str):str;
var x:str; i:integer;
begin
x:=s;
for i:=1 to length(s) do
x[i]:=upcase(x[i]);
uc:=x;
end;
procedure dlx(f1:ulfrec; var abort:boolean);
var inte,pl,c:integer; ok,tl:boolean; u:userrec; rl:real; i,ii:str;
begin
nl; nl;
print('Filename: "'+align(f1.filename)+'"');
print('Desc. : '+f1.description);
print('# blocks: '+cstr(f1.blocks)+'-'+cstr((f1.blocks+7)div 8));
inte:=value(spd); if inte=0 then inte:=1200;
rl:=1620.0*f1.blocks/inte;
if rl>32767.0 then rl:=32000; if rl<0.0 then rl:=0;
inte:=trunc(rl);
i:=cstr(inte div 3600)+':'; ii:=cstr((inte mod 3600) div 60);
if length(ii)=1 then ii:='0'+ii; i:=i+ii+':';
ii:=cstr(inte mod 60); if length(ii)=1 then ii:='0'+ii;
i:=i+ii; print('apx time: '+i);
reset(uf); seek(uf,f1.owner); read(uf,u); close(uf);
print('U/L by : '+u.name+' #'+cstr(f1.owner));
print('U/L on : '+f1.date);
ft:=255; if (f1.ft[1]=$81) and (f1.ft[2]=$f5) then ft:=f1.ft[3];
if ft<>255 then print('File typ: '+cstr(ft));
if timer<timeon then timeon:=timeon-24.0*60*60;
tl:=((seclev[thisuser.sl].ttime*60+extratime+timeon-timer-rl)>0);
if tl or (copy(f1.filename,1,4)='WWIV') then begin
if exist('dloads\'+f1.filename) then
send1('dloads\'+f1.filename,ok,abort)
else print('File isn''t really there!');
end else print('Not enough time left to D/L');
end;
procedure dl(fn:str);
var pl,rn:integer; f:ulfrec; abort:boolean;
begin
recno(fn,pl,rn); abort:=false;
if rn=0 then print('File not found.') else begin
while (rn<>0) and (not abort) do begin
seek(ulff,rn); read(ulff,f); dlx(f,abort);
nrecno(fn,pl,rn);
end;
end;
close(ulff);
end;
procedure dl1(n:integer);
var f1:ulfrec; abort:boolean;
begin
nl; nl;
seek(ulff,n); read(ulff,f1);
dlx(f1,abort);
nl;
end;
procedure ul(fn:str);
var x,pl,c,cc,ob,np:integer; f,f1:ulfrec; uls,ok:boolean; fi:file of byte;
begin
if freek>80 then begin
uls:=incom;
ob:=culb;
ok:=true; fn:=align(fn);
if (fn[1]=' ') or (fn[10]=' ') then ok:=false;
for x:=1 to length(fn) do
if not (fn[x] in ['0'..'9','A'..'Z','.',' ']) then ok:=false;
np:=0; for x:=1 to length(fn) do if fn[x]='.' then np:=np+1;
if np<>1 then ok:=false;
if ok then
if incom then
if exist('dloads\'+fn) then
if cs then begin
print('There already is one.');
prompt('Do it anyways? ');
ok:=yn;
uls:=false;
end else
ok:=false
else
ok:=true
else
ok:=exist('dloads\'+fn)
else print('Illegal filename.');
if (not incom) then
if ok then print('Am using the file in dloads\')
else begin print('To put in a file from keyboard, it must already be');
print('present in the dloads\ directory.'); end;
nl; nl;
if ok and incom and uls then begin
assign(fi,'dloads\'+fn); {$I-} rewrite(fi); {$I+}
if ioresult<>0 then begin
{$I-} close(fi); {$I+} cc:=ioresult;
ok:=false;
end else begin close(fi); erase(fi); end;
end;
if not ok then print('Can''t use that filename, sorry.') else begin
iscan(pl);
if pl>=uboards[culb].maxfiles then print('This board is full.') else begin
prompt('Upload "'+fn+'" ? ');
if yn then begin ok:=true; close(ulff);
nl; print('Please enter a one line description.'); prompt(':');
inputl(f.description,60);
if (f.description[1]='\') or (rvalidate in thisuser.ac) then culb:=0;
if f.description[1]='\' then f.description:=copy(f.description,2,80);
iscan(pl);
ok:=true; ft:=255;
if uls then receive1('dloads\'+fn,ok);
nl; nl;
if not ok then print('Not saved.') else begin
f.filename:=fn;
f.owner:=usernum;
f.date:=date;
f.daten:=daynum(date);
for x:=1 to 17 do f.res[x]:=0;
for x:=1 to 3 do f.ft[x]:=0;
if ft<>255 then begin
f.ft[1]:=$81; f.ft[2]:=$f5; f.ft[3]:=ft;
end;
assign(fi,'dloads\'+fn);
{$I-} reset(fi); {$I+}
if ioresult=0 then begin
f.blocks:=trunc((longfilesize(fi)+127.0)/128.0);
close(fi);
for x:=pl downto 1 do begin
seek(ulff,x); read(ulff,f1);
seek(ulff,x+1); write(ulff,f1);
end;
seek(ulff,1);
write(ulff,f);
seek(ulff,0); read(ulff,f); f.blocks:=pl+1;
seek(ulff,0); write(ulff,f);
sysoplog('Uploaded "'+fn+'" on '+uboards[culb].name);
print('File successfully uploaded.');
end else begin
print('Oops, system error. Not saved.');
sysoplog('Error uploading "'+fn+'"');
end;
end;
end;
end;
close(ulff); culb:=ob;
end;
nl; nl;
end else begin
nl; nl; print('Sorry, not enough disk space.');
nl;
end;
end;
procedure idl;
var i:str;
begin
helpl:='X';
nl; print('Download -'); nl; prompt('Enter filename: '); input(i,12);
dl(i);
nl; nl;
end;
procedure iul;
var i:str;
begin
helpl:='U';
nl; nl; print('Upload -'); nl; prompt('Enter filename: '); input(i,12);
ul(i);
nl; nl;
end;
procedure gfn(var fn:str);
begin
nl; helpl:='L';
prompt('File mask: '); input(fn,12);
if fn='' then fn:='*.*';
fn:=align(fn);
end;
function aln(i:str; n:integer):str;
begin
while length(i)<n do i:=' '+i;
aln:=i;
end;
procedure pfn(f:ulfrec; var abort,next:boolean);
begin
printacr(align(f.filename)+':'+aln(cstr(f.blocks),4)+' :'+f.description,abort,next);
end;
procedure searchb(b:integer; fn:str; var abort:boolean);
var oldboard,pl,rn:integer; f:ulfrec;
begin
oldboard:=culb; culb:=b;
recno(fn,pl,rn);
while (rn<=pl) and (not abort) and (not hangup) and (rn<>0) do begin
seek(ulff,rn); read(ulff,f);
pbn(abort);
pfn(f,abort,next);
nrecno(fn,pl,rn);
end;
close(ulff);
culb:=oldboard;
end;
procedure searchbd(b:integer; ts:str; var abort:boolean);
var oldboard,pl,rn:integer; f:ulfrec; next:boolean;
begin
oldboard:=culb; culb:=b; iscan(pl);
rn:=1;
while (rn<=pl) and (not abort) and (not hangup) do begin
seek(ulff,rn); read(ulff,f);
if pos(ts,uc(f.description))<>0 then begin
pbn(abort);
pfn(f,abort,next);
end;
rn:=rn+1;
end;
close(ulff);
culb:=oldboard;
end;
procedure search;
var fn:str; bn:integer; abort:boolean;
begin
nl; nl; print('Search all directories.');
gfn(fn);
if cs then bn:=0 else bn:=1; abort:=false;
while (not abort) and (bn<=maxulb) and (not hangup) do begin
if uboards[bn].dsl<=thisuser.dsl then searchb(bn,fn,abort);
bn:=bn+1;
end;
end;
procedure searchd;
var fn:str; bn:integer; abort:boolean;
begin
nl; nl; print('Find a description -'); nl;
print('Enter what to search description for.');
helpl:='Y';
prompt(': '); input(fn,20);
if fn<>'' then begin
nl; print('Searching for "'+fn+'"'); nl;
prompt('Search all directories? ');
if yn then begin
if cs then bn:=0 else bn:=1; abort:=false;
while (not abort) and (bn<=maxulb) and (not hangup) do begin
if uboards[bn].dsl<=thisuser.dsl then searchbd(bn,fn,abort);
bn:=bn+1;
end;
end else searchbd(culb,fn,abort);
end;
end;
procedure newfiles(b:integer; var abort:boolean);
var oldboard,pl,rn,ldn:integer; f:ulfrec; next:boolean;
begin
oldboard:=culb; culb:=b; iscan(pl);
ldn:=daynum(ldat);
rn:=1;
while (rn<=pl) and (not abort) and (not hangup) do begin
seek(ulff,rn); read(ulff,f);
if f.daten>=ldn then begin
pbn(abort);
pfn(f,abort,next);
end;
rn:=rn+1;
end;
close(ulff);
culb:=oldboard;
end;
procedure nf;
var bn:integer; abort:boolean;
begin
nl; print('Search for new files.'); nl;
prompt('Search all directories? ');
if yn then begin
if cs then bn:=0 else bn:=1; abort:=false;
while (not abort) and (bn<=maxulb) and (not hangup) do begin
if uboards[bn].dsl<=thisuser.dsl then newfiles(bn,abort);
bn:=bn+1;
end;
end else newfiles(culb,abort);
end;
procedure delete(rn:integer; var pl:integer);
var f:ulfrec; i:integer;
begin
if (rn<=pl) and (rn>0) then begin
pl:=pl-1;
for i:=rn to pl do begin
seek(ulff,i+1); read(ulff,f);
seek(ulff,i); write(ulff,f);
end;
seek(ulff,0); f.blocks:=pl; write(ulff,f);
end;
end;
procedure remove;
var pl,c,rn:integer; f:ulfrec; fn:str; ff:file; u:userrec; tf:boolean;
begin
print('Enter filename to remove.'); prompt(': ');
input(fn,12);
if fn<>'' then begin
recno(fn,pl,rn);
if rn<>0 then begin
seek(ulff,rn); read(ulff,f);
if (usernum=f.owner) or cs then begin
print('Filename: "'+f.filename+'"');
print('Desc. : '+f.description);
print('# blocks: '+cstr(f.blocks));
reset(uf); seek(uf,f.owner); read(uf,u); close(uf);
print('U/L by : '+u.name+' #'+cstr(f.owner));
print('U/L on : '+f.date);
prompt('Delete this? ');
if yn then begin
delete(rn,pl);
if cs then begin
prompt('Erase file too? ');
tf:=yn;
end else tf:=true;
if tf then begin
assign(ff,'dloads\'+fn);
{$I-} erase(ff); {$I+}
c:=ioresult;
end;
end;
end;
end;
close(ulff);
end;
nl; nl;
end;
procedure move;
var x,pl,c,rn,int,dbn:integer; f,f1:ulfrec; fn:str; ff:file; i:str;
abort,next:boolean;
begin
print('Enter filename to move.'); prompt(': ');
input(fn,12);
if fn<>'' then begin
recno(fn,pl,rn);
if rn<>0 then begin
seek(ulff,rn); read(ulff,f);
abort:=false; nl; pfn(f,abort,next); nl; nl;
prompt('Move this? ');
if yn then begin
nl;
for int:=0 to maxulb do
print(cstr(int)+' : '+uboards[int].name);
nl; nl;
prompt('To which directory? '); input(i,3);
dbn:=value(i); if (dbn=0) and (i<>'0') then dbn:=-1;
if (dbn<0) or (dbn>maxulb) then print('Can''t move it there.')
else begin
delete(rn,pl);
close(ulff);
int:=culb; culb:=dbn; iscan(pl);
for x:=pl downto 1 do begin
seek(ulff,x); read(ulff,f1);
seek(ulff,x+1); write(ulff,f1);
end;
seek(ulff,1);
write(ulff,f);
f.blocks:=pl+1;
seek(ulff,0); write(ulff,f);
culb:=int;
end;
end;
end;
close(ulff);
end;
end;
procedure ren;
var pl,c,rn,int,dbn:integer; f:ulfrec; fn,fd:str; ff:file; i:str;
begin
print('Enter filename to rename.'); prompt(': ');
input(fn,12); nl; nl;
if fn<>'' then begin
recno(fn,pl,rn);
if rn<>0 then begin
seek(ulff,rn); read(ulff,f);
print(align(f.filename)+' : '+f.description); nl; nl;
prompt('Rename this stuff? ');
if yn then begin
prompt('New filename? '); input(fn,12);
if fn<>'' then begin
if exist('dloads\'+fn) then print('Can''t use that filename.') else begin
chdir('dloads'); assign(ff,f.filename); rename(ff,fn); chdir('..');
f.filename:=fn;
end;
end;
print('New description -'); prompt(': '); inputl(fd,60);
if fd<>'' then f.description:=fd;
seek(ulff,rn); write(ulff,f);
end;
end;
close(ulff);
end;
end;
function gtr(f,f1:ulfrec):boolean;
begin
if sortbd and (f1.daten<>f.daten) then
if f1.daten<f.daten then
gtr:=false
else
gtr:=true
else
if f1.filename>f.filename then
gtr:=false
else
gtr:=true;
end;
procedure sortd(c:integer);
var oldboard,trn,srn,i,i1,pl:integer; f,f1:ulfrec;
begin
oldboard:=culb; culb:=c; iscan(pl);
nl; print('Sorting '+uboards[culb].name);
for i:=1 to pl-1 do begin
seek(ulff,i); read(ulff,f); trn:=i;
for i1:=i+1 to pl do begin
seek(ulff,i1); read(ulff,f1);
if gtr(f,f1) then begin
f:=f1; trn:=i1;
end;
end;
seek(ulff,i); read(ulff,f1); seek(ulff,i);
write(ulff,f); seek(ulff,trn); write(ulff,f1);
end;
close(ulff);
culb:=oldboard;
end;
procedure sort;
var bn:integer;
begin
nl; nl; prompt('Sort by date? '); if yn then sortbd:=true else sortbd:=false;
nl; prompt('Sort all boards? ');
if yn then
for bn:=0 to maxulb do
sortd(bn)
else
sortd(culb);
end;
procedure listfiles;
var abort:boolean; fn:str;
begin
nl; nl; print('List files.');
gfn(fn); abort:=false;
searchb(culb,fn,abort);
end;
procedure listf(n:integer; var abort:boolean);
var f:ulfrec; i,i1:str; next:boolean;
begin
seek(ulff,n); read(ulff,f);
i:=cstr(n); while length(i)<3 do i:=' '+i;
i:=i+': '+align(f.filename);
while length(i)<20 do i:=i+' ';
i1:=cstr(f.blocks); while length(i1)<5 do i1:=' '+i1; i:=i+i1;
i:=i+' '+f.date+' '; i1:=cstr(f.owner); while length(i1)<3 do i1:=' '+i1;
i:=i+i1;
printacr(i,abort,next);
end;
procedure browsefiles;
var pl,n,nfl,cn:integer; f:ulfrec; i,i1:str; abort,next,list,done:boolean;
begin
iscan(pl); nl; nl; helpl:='B';
print('('+uboards[culb].name+') - '+cstr(pl)+' files');
if pl<>0 then begin
nl; abort:=false; done:=false;
prompt('Start at? '); input(i,3); cn:=value(i); if cn=0 then cn:=1;
if i='Q' then cn:=0; if cn>pl then cn:=0;
if cn>0 then begin list:=true;
repeat
tleft;
if list then begin
if cn>pl then cn:=1;
nfl:=0;
print(' NN: filename.ext blcks mm/dd/yy frm');
while (not hangup) and (nfl<10) and (not abort) and (cn<=pl) do begin
listf(cn,abort); cn:=cn+1; nfl:=nfl+1;
end;
list:=false;
end;
nl; prompt('Browse: (1-'+cstr(pl)+',^'+cstr(cn)+'),U,D,Q,L,? :');
input(i,3); n:=0;
if (i='') and (cn>pl) then i:='Q';
n:=value(i); if (n>0) and (n<=pl) then begin cn:=n; i:='D'; end;
if i='?' then begin print('U:pload D:ownload');
print('Q:uit L:ist files'); end;
if i='Q' then done:=true;
if i='L' then list:=true;
if i='U' then begin close(ulff); iul; iscan(pl); end;
if i='D' then begin
if n=0 then begin print('Download -'); nl; prompt('Which number? ');
input(i1,3); n:=value(i1); end;
if (n>0) and (n<=pl) then dl1(n);
end;
until done or hangup;
end;
end;
close(ulff);
end;
procedure pointdate;
var i:str; n:integer;
begin
nl; nl; nl; helpl:='P';
print('Enter limiting date for new files -');
print('Date is currently set to '+ldat);
print(' mm/dd/yy');
prompt(':'); input(i,8);
nl; nl;
n:=daynum(i);
if n=0 then
print('Illegal date.')
else
ldat:=i;
nl; print('Current limiting date is '+ldat);
end;
procedure listboards;
var b:integer; i:str; abort,next:boolean;
begin
nl;nl; print('Directories available to you:'); nl; nl;
b:=1; abort:=false;
while (b<=maxulb) and (not abort) and (not hangup) do begin
if uboards[b].dsl<=thisuser.dsl then begin
i:=cstr(b);
if length(i)=1 then i:=' '+i;
i:=i+' : '+uboards[b].name;
printacr(i,abort,next);
end;
b:=b+1;
end;
nl;nl;
end;
procedure mmkey(var i:str);
var c:char;
begin
repeat
repeat
getkey(c);
skey(c);
until (((c>=' ') and (c<chr(127))) or (c=chr(13))) or hangup;
c:=upcase(c);
outkey(c);
thisline:=thisline+c;
if (c='/') or (c='1') then begin
i:=c;
repeat
getkey(c);
skey(c);
until ((c>=' ')and(c<=chr(127))) or (c=chr(13)) or (c=chr(8)) or hangup;
c:=upcase(c);
if c<>chr(13) then begin outkey(c); thisline:=thisline+c; end;
if (c=chr(8)) or (c=chr(127)) then prompt(' '+c);
if c='/' then input(i,20) else if c<>chr(13) then i:=i+c;
end else i:=c;
until (c<>chr(8)) and (c<>chr(127)) or hangup;
nl;
end;
procedure reqchat;
begin
nl;nl; if (not sysop) or (rchat in thisuser.ac)
then begin
print('Sysop not available.');
end else begin
if not chatcall then begin
helpl:='C'; prompt('Reason: '); inputl(i,70);
if i<>'' then begin
sysoplog('Chat: '+i);
print('Chat call now on.');
sound(440); delay(500); nosound;
chatr:=i; chatcall:=true;
end else chatr:='';
end else
begin chatcall:=false; print('Chat call turned off.'); chatr:='';end;
end;
nl;nl; topscr;
end;
procedure yourinfo;
begin
nl; nl;
print('Your name : '+nam);
print('Your SL : '+cstr(thisuser.sl));
print('Your DSL : '+cstr(thisuser.dsl));
print('You D/L''d : '+cstr(thisuser.dk)+'K in '+cstr(thisuser.downloads)+' files');
print('You U/L''d : '+cstr(thisuser.uk)+'K in '+cstr(thisuser.uploads)+' files');
end;
procedure ftmainmenu;
var ii,i:str; int:integer;
begin
dump; tleft; nl; nl;
print('T - '+tlef);
i:='('+cstr(culb)+')-('+uboards[culb].name+') :';
prompt(i);
helpl:='T';
mmkey(i);
helpl:=#0;
if length(i)=1 then case i[1] of
'?':printfile('gfiles\dlmenu.msg');
'Q':doneft:=true;
'B':browsefiles;
'U':iul;
'D':idl;
'L':listfiles;
'S':search;
'F':searchd;
'C':reqchat;
'O':begin
nl;nl;prompt('Hangup? Sure? '); helpl:='O';
if yn then begin
cls;
printfile('gfiles\logoff.msg');
hangup:=true;
hungup:=false;
end;
end;
'*':listboards;
'P':pointdate;
'N':nf;
'R':remove;
'M':if cs then move;
'V':lfii;
'Y':yourinfo;
end;
if i='/O' then hangup:=true;
if (i='SORT') and cs then sort;
if (i='REN') and cs then ren;
if (i='0') and cs then culb:=0;
int:=value(i); if (int>0) and (int<=maxulb) then
if thisuser.dsl>=uboards[int].dsl then
if (uboards[int].password='') or cs then culb:=int else begin
prompt('Password? '); input(i,10);
if i<>uboards[int].password then
print('Wrong.')
else
culb:=int;
end;
end;
begin
iport; i1; doneft:=false;
while (not doneft) and (not hangup) do
ftmainmenu;
ret:=200;
return;
end.